package Perlbal::Plugin::Accesslog;
use strict;
use warnings;

use Class::Inspector;
use Carp;
use POSIX;
use IO::File;

my %SERVICE_HOOK = (
    'reverse_proxy' => 'end_proxy_request',
    'web_server'    => 'modify_response_headers',
);

=head1 NAME

Perlbal::Plugin::Accesslog - The great new Perlbal::Plugin::Accesslog!

=head1 VERSION

Version 0.02

=cut

our $VERSION = '0.02';


=head1 SYNOPSIS

Quick summary of what the module does.

Perhaps a little code snippet.

    use Perlbal::Plugin::Accesslog;

    my $foo = Perlbal::Plugin::Accesslog->new();
    ...

=head1 METHODS

=head2 err

=cut

sub err {
    croak("Accesslog: " . shift);
}

=head2 load

Called when "LOAD accesslog" is parsed

=cut

sub load {
    my $class = shift;

    # Called when "ACCESSLOG <service>..." is parsed
    Perlbal::register_global_hook('manage_command.accesslog', sub {
        my $mc = shift->parse(qr/^accesslog\s+(?:(\w+)\s+)?=\s*(\S+)\s+(\S+)$/,
                              "usage: ACCESSLOG [<service>] = <backend type> <backend specifier>");
        my ($selname, $backend, $spec) = $mc->args;
        unless ($selname ||= $mc->{ctx}{last_created}) {
            return $mc->err("omitted service name not implied from context");
        }

        my $ss = Perlbal->service($selname);
        return $mc->err("Service '$selname' is not a compatible Accesslog service")
            unless $ss && $ss->{role} =~ /^web_server|reverse_proxy|management$/;
            
        $ss->{extra_config}->{_accesslog} ||= {};
        $ss->{extra_config}->{_accesslog}{loggers} ||= ();

        # Initilize the backend and store it in the config
        # get_backend will croak if backend can't be loaded
        my $logger = get_backend($backend)->new($spec);
        push @{$ss->{extra_config}->{_accesslog}{loggers}}, $logger;

        return $mc->ok;
    });
    return 1;
}

=head2 register

Called when "SET plugins = accesslog..." is parsed.

=cut

sub register {
    my ($class, $svc) = @_;
    
    my $role     = $svc->{role};
    
    Perlbal::Plugin::Accesslog::err("Service $svc->{name} must have a role assigned before Accesslog can be registered to it")
        unless $role;
    
    $svc->{extra_config}->{_accesslog}          ||= {};
    $svc->{extra_config}->{_accesslog}{loggers} ||= ();
    
    # Wrap a closure around our Sevice->{extra_config} stuff to get a
    # reference to the list of loggers. This way, it works whether
    #   "SET plugins = accesslog..."
    # is called before or after the
    #   "ACCESSLOG = ... " 
    # declarations. 
    my $hook_ref 
        = sub { 
            HOOK_fire_loggers(shift, $svc->{extra_config}->{_accesslog}{loggers}) 
        };
      
    # Hook based on service type  
    my $hook     = $SERVICE_HOOK{$role};
    Perlbal::Plugin::Accesslog::err("No SERVICE HOOK defined for Service $svc->{name} with role $role")
        unless $hook;
    
    $svc->register_hook('Accesslog', $hook, $hook_ref);
    return undef if $@;
}

=head2 unregister

=cut

# called when we're no longer active on a service
sub unregister {
    my ($class, $svc) = @_;
    
    $svc->unregister_hooks('Accesslog');
    
    return 1;
}

=head1 FUNCTIONS

=cut

sub HOOK_fire_loggers {
    my ( $http_client, $loggers ) = @_;
    
    my $req = $http_client->{req_headers};
    my $res = $http_client->{res_headers};
    
    
    foreach my $logger (@{$loggers}) {
        eval "$logger->log($http_client)"; 
    }

    return 0;
}

sub get_backend {
    my ( $backend ) = @_;
    
    my $class = join('::', __PACKAGE__, lc($backend));
    
    unless ( Class::Inspector->loaded($class) ) {
        eval "require $class";
        Perlbal::Plugin::Accesslog::err("Could not load Accesslog backend class $class: $@") if $@;
    }
    
    return $class;
}

=head1 AUTHOR

Matthew Pitts, C<< <mpitts at a3its.com> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-perlbal-plugin-accesslog at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Perlbal-Plugin-Accesslog>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.



=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Perlbal::Plugin::Accesslog


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Perlbal-Plugin-Accesslog>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Perlbal-Plugin-Accesslog>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/Perlbal-Plugin-Accesslog>

=item * Search CPAN

L<http://search.cpan.org/dist/Perlbal-Plugin-Accesslog>

=back


=head1 ACKNOWLEDGEMENTS

Paul Vogel,    C<< <paulv at watje.org> >> wrote the syslog support, and did some modifications

=head1 COPYRIGHT & LICENSE

Copyright 2007 Matthew Pitts, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.


=cut

1; # End of Perlbal::Plugin::Accesslog

package Perlbal::Plugin::Accesslog::base;
use strict;
use warnings;

use POSIX qw/ strftime /;
use Carp;


my $STRFTIME = '%d/%b/%Y:%T %z';

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    
    my $self = {};
    
    bless $self, $class;
    
    $self->BUILD(@_);
    
    return $self;
}

sub log {
    my $self = shift;
    my ( $client ) = @_;
    
    my $msg;

    $msg 
        = join(
            ' ',
                   log_remote_addr    ( $client               )       ,
                   log_virtual_host   ( $client               )       ,
                   log_remote_logname ( $client               )       ,
                   log_remote_user    ( $client               )       ,
                   log_request_time   ( $client               )       ,
            q{"} . log_request_line   ( $client               ) . q{"},
                   log_status         ( $client               )       ,
                   log_bytes_sent     ( $client               )       ,
            q{"} . log_header_in      ( $client, 'REFERER'    ) . q{"},
            q{"} . log_header_in      ( $client, 'USER-AGENT' ) . q{"}
        );
    
    $self->write_log($msg);
}

sub err {
    my $self = shift;
    
    croak("Accesslog: " . shift);
}

sub log_virtual_host {
    my $client = shift;
    
    return log_header_in($client, 'HOST');
}

sub log_remote_addr {
    my $client = shift;
    
    return $client->peer_ip_string || return '-';
}

sub log_remote_logname {
    return q{-};
}

sub log_remote_user {
    return q{-};
}

sub log_request_time {
    my $client = shift;

    return q{[} . strftime($STRFTIME, localtime($client->{create_time})) . q{]};
}

sub log_request_line {
    my $client = shift;
    
    return $client->{res_headers}->getURI() or 
    return '-';  
}

sub log_status {
    my $client = shift;
    
    return $client->{res_headers}->{code}; 
    return '-';  
}

sub log_bytes_sent {
    my $client = shift;

    return $client->{res_headers}->content_length if defined $client->{res_headers}->content_length;
    return '-';  
}

sub log_header_in {
    my ( $client, $key ) = @_;

    return $client->{req_headers}->header(lc($key)) if exists $client->{res_headers};
    return '-';   
}

sub log_header_out {
    my ( $client, $key ) = @_;

    return $client->{res_headers}->header(lc($key)) if exists $client->{res_headers};
    return '-';        
}

1;

package Perlbal::Plugin::Accesslog::file;
use strict;
use warnings;
use IO::File;



use base qw/Perlbal::Plugin::Accesslog::base/;

sub BUILD {

    my $self = shift;
    my ( $file ) = @_;
    
    $self->{file} = $file;
    $self->open_fh;
}

sub open_fh {
    my $self = shift;
    
    Perlbal::Plugin::Accesslog::err("No file specified to open")
        unless $self->{file};
    
    my $file = $self->{file};
    my $fh   = IO::File->new();
    
    Perlbal::Plugin::Accesslog::err("Failed to open log file:" . $self->{file} . ' ' . $!)
        unless $fh->open($self->{file}, O_NONBLOCK|O_WRONLY|O_APPEND|O_CREAT, 0644); 

    # you might want to turn off autoflush for performance 
    $fh->autoflush(1);

    $self->{fh} = $fh;
}


sub write_log {
    my $self = shift;
    my ( $msg ) = @_;
    
    # Add a line return
    $msg .= "\n" unless $msg =~ /\n$/;
    eval{$self->{fh}->print($msg)}; 

}

1;

package Perlbal::Plugin::Accesslog::stomp;
use strict;
use warnings;

use base qw/Perlbal::Plugin::Accesslog::base/;

use Regexp::Common qw/ net /;

sub BUILD {
    my $self = shift;
    my ( $spec ) = @_;
    
    unless ( Class::Inspector->loaded('Net::Stomp') ) {
        eval "require Net::Stomp";
        Perlbal::Plugin::Accesslog::err("Could not load Net::Stomp: $@") if $@;
    }
    
    my ( $host, $port, $queue ) = split(/:/, $spec);
    
    unless ( $host =~ /^$RE{net}{IPv4}|$RE{net}{domain}|localhost$/ ) {
        Perlbal::Plugin::Accesslog::err("$spec is not a valid specifier for a stomp logger");
    }
    
    unless ( $port =~ /^\d{1,5}$/ ) {
        Perlbal::Plugin::Accesslog::err("$spec is not a valid specifier for a stomp logger");
    }
    
    unless ( $queue =~ /^\/\S+\/\S+$/ ) {
        Perlbal::Plugin::Accesslog::err("$spec is not a valid specifier for a stomp logger");
    }
    
    $self->{host}  = $host;
    $self->{port}  = $port;
    $self->{queue} = $queue;
    
    $self->connect;
}

sub connect {
    my $self = shift;
    
    my $stomp;
    
    eval { 
        $stomp = Net::Stomp->new( 
            { hostname => $self->{host}, port => $self->{port} } 
        );
    
        $stomp->connect( { login => 'hello', passcode => 'there' } );
    };
    if ($@) {
        Perlbal::Plugin::Accesslog::err("Could not connect to STOMP server: $@");
    }
    
    $self->{stomp} = $stomp;
}

sub connected {
    my $self = shift;
    
    return $self->{stomp}->socket->connected;
}

sub write_log {
    my $self = shift;
    my ( $msg ) = @_;
    
    $self->connect unless $self->connected;
    
    $self->{stomp}->send(
        { destination => $self->{queue}, body => $msg } 
    );
}

1;

package Perlbal::Plugin::Accesslog::syslog;
use strict;
use warnings;
use Log::Syslog::UDP;

use base qw/Perlbal::Plugin::Accesslog::base/;

use Regexp::Common qw/ net /;

sub BUILD {
    my $self = shift;
    my ( $spec ) = @_;
    
    my ( $host, $port, $facility, $severity, $sender, $name ) = split(/:/, $spec);
    
    unless ( $host =~ /^$RE{net}{IPv4}|$RE{net}{domain}|localhost$/ ) {
        Perlbal::Plugin::Accesslog::err("$host is not a valid syslog host target");
    }
    
    unless ( $port =~ /^\d{1,5}$/ ) {
        Perlbal::Plugin::Accesslog::err("$port is not a valid syslog port");
    }
    
    unless (  $facility =~ /^LOG_[[:upper:]]{1,8}/ ) { 
        Perlbal::Plugin::Accesslog::err("$facility is not a valid syslog facility");
    }
    
    unless (  $severity =~ /^LOG_[[:upper:]]{1,8}/ ) { 
        Perlbal::Plugin::Accesslog::err("$severity is not a valid syslog priority");
    }
    
    unless (  $sender =~ /\w+/ ) { 
        Perlbal::Plugin::Accesslog::err("$sender is not a valid syslog sender");
    }
    
    unless (  $name =~ /\w+/ ) { 
        Perlbal::Plugin::Accesslog::err("$name is not a valid syslog name");
    }
    
    $self->{host}     = $host;
    $self->{port}     = $port;
    $self->{sender}   = $sender;
    $self->{name}     = $name;

    { # lets have lots of fun getting the value of a constant.
	no strict 'refs';
	$facility = 'Log::Syslog::UDP::' . $facility;  # the realname of the constant
    	$self->{facility} = &$facility();              # the value of the constant
	$severity = 'Log::Syslog::UDP::' . $severity;  # the realname of the constant
    	$self->{severity} = &$severity();              # the value of the constant
    }

    $self->connect;
}


sub connect {
    my $self = shift;
    
    my $logger;

    eval { 
    	$logger = Log::Syslog::UDP->new( $self->{host}, $self->{port}, $self->{facility}, $self->{severity}, $self->{sender}, $self->{name});
    };

    if ($@) {
        Perlbal::Plugin::Accesslog::err("Could not connect to syslog server: $@");
    }
    
    $self->{logger} = $logger;
}

sub write_log {
    my $self = shift;
    my ( $msg ) = @_;

    $self->{logger}->send($msg, time);
}

1;
